home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
MENU_UTL
/
DESIGN
/
IBMLIB1.INC
< prev
next >
Wrap
Text File
|
1988-12-28
|
18KB
|
724 lines
procedure cls;
begin
gotoxy(1,1);
clrscr
end;
procedure setcurs(n:Integer);
{ Set cursor size to n scan lines }
Type
String80 = String[80];
var
regs : registers;
begin
if not (n in [1..7]) then
n := 6; { One scan line if out of bounds }
regs.ah := 1; { Set cursor size }
regs.ch := 7-n; { Top scan line }
regs.cl := 7; { Bottom scan line }
intr($10,regs); { Call video I/O }
end;
Procedure Beep;
Begin
Write(chr(7))
end; { Beep }
Function Yes : Boolean;
Const
YesNo : Set of Char = ['Y','y','N','n'];
Var
C : Char;
Ok, Ans : Boolean;
Begin
Repeat
C := ReadKey;
Ok := (C in YesNo);
If Not OK then Beep;
Until OK;
Ans := (UpCase(C) = 'Y');
if Ans then write('Y') else
write('N');
Yes := Ans;
end; { Yes }
Function YYes : Boolean;
{ Gets Yes/No answer while keeping up clock }
Const
YesNo : Set of Char = ['Y','y','N','n'];
Var
C : Char;
Ok, Ans : Boolean;
Begin
Repeat
C := ReadKey;
Ok := (C in YesNo);
If Not OK then Beep;
Until OK;
Ans := (UpCase(C) = 'Y');
YYes := Ans;
end; { Yes }
{ -------------------------------------------------------- }
Function Spaces(n:Integer):String80;
var
i : Integer;
Sp : String80;
begin
sp := '';
for i := 1 to n do
sp := concat(sp,#32);
Spaces := sp
end;
function blank(str:String80):boolean;
var
i : Integer;
temp : boolean;
begin
temp := true;
for i := 1 to length(str) do
if str[i] <> #32 then temp := false;
blank := temp
end;
{ ----------------------------------------------------- }
procedure fwrite(col,row,attrib:byte;str:String80);
{ Write directily to video memory }
begin
inline
($1E/$1E/$8A/$86/row/$B3/$50/$F6/$E3/$2B/$DB/$8A/$9E/col/
$03/$C3/$03/$C0/$8B/$F8/$be/$00/$00/$8A/$BE/attrib/
$8a/$8e/str/$22/$c9/$74/$3e/$2b/$c0/$8E/$D8/$A0/$49/$04/
$1F/$2C/$07/$74/$22/$BA/$00/$B8/$8E/$DA/$BA/$DA/$03/$46/
$8a/$9A/str/$EC/$A8/$01/$75/$FB/$FA/$EC/$A8/$01/$74/$FB/
$89/$1D/$47/$47/$E2/$Ea/$2A/$C0/$74/$10/$BA/$00/$B0/
$8E/$DA/$46/$8a/$9A/str/$89/$1D/$47/$47/$E2/$F5/$1F);
end;
procedure time(var line:String15; var AmPm:String5);
var
register : Registers;
Hour,Min,Sec,Hun : Integer;
hours, minutes, seconds : String[5];
begin
register.AX := $2C00;
MsDos(Register);
With Register do
begin
Hour := Cx shr 8;
Min := Cx and $00FF;
Sec := Dx shr 8;
Hun := Dx and $00FF;
end;
if hour > 11 then
ampm := ' PM' else
ampm := ' AM';
if hour > 12 then
hour := hour - 12;
str(hour:2,hours);
if hours[1] = #32 then hours[1] := '0';
if hours = '00' then hours := '12';
str(min:2,minutes);
if minutes[1] = #32 then minutes[1] := '0';
str(sec:2,seconds);
if seconds[1] = #32 then seconds[1] := '0';
line := Hours+':'+Minutes+':'+Seconds;
end;
{ -------------------------------------------------------- }
Procedure Date(var line:String15);
Type
Str9 = String[9];
Const
Dates : Array[1..7] of str9 = ('Sunday','Monday','Tuesday','Wednesday',
'Thursday','Friday','Saturday');
Var
Regs : Registers;
DayNum,Month,Day,Year : Integer;
MStr,DStr,YStr : String[2];
Begin
Regs.Ax := $2A00;
MsDos(Regs);
DayNum := (Regs.Ax and $00FF) + 1;
Month := Regs.Dx shr 8;
Day := Regs.Dx and $00FF;
Year := Regs.Cx - $76C; { Subtract 1900 so we get a two digit year }
str(month:2,mstr);
str(day:2,dstr);
str(year:2,ystr);
if mstr[1] = #32 then mstr[1] := '0';
if dstr[1] = #32 then dstr[1] := '0';
if ystr[1] = #32 then dstr[1] := '0';
line := mstr+'/'+dstr+'/'+ystr+'.'
end;
procedure display_datetime;
begin
date(The_Date);
time(The_Time,AmPm);
fwrite(50,2,lbg*16+lfg,The_Date+' - '+The_Time+AmPm)
end;
procedure clock;
begin
if not clockon then exit;
while not keypressed do
begin
temp := temptime;
time(temptime,AmPm);
if temp <> temptime then
display_datetime
end;
end;
{ -------------------------------------------------------- }
Function Color_Monitor: Boolean;
const
ZeroSeg = $0000;
ConfigWorld = $0410;
var
Flag : byte;
Ch : char;
begin
Flag := (Mem [ZeroSeg:ConfigWorld])
and $30;
if Flag = $20 then
Color_Monitor := true
else if Flag = $30 then
Color_Monitor := false
else
begin
Make_Window(10,10,70,15,f,b);
writeln('I can`t determine what kind of monitor you have.');
writeln('The default will be Monochrome.');
Color_Monitor := false;
writeln;
writeln('Press any key...');
Ch := ReadKey;
Remove_Window
end;
end;
{ -------------------------------------------------------- }
function Strings(n:Integer;ch:char):String80;
{ Emulate the BASIC STRING$ function }
var
i : Integer;
temp : String80;
begin
temp := '';
for i := 1 to n do
temp := concat(temp,ch);
Strings := temp
end;
procedure GetIntVal(Var Value:Integer; xpos,ypos:Integer;
var up,q:boolean);
{ Do error checking on Integer number input }
var
tempString, tempval : String10;
code : Integer;
begin
str(value,tempval);
gotoxy(xpos,ypos);
repeat
tempString := '';
EditLine(TempString,8,WhereX,WhereY,LegalChars,Term,Tc);
Up := Tc = UpKey;
q := Tc = Esc;
if tempString = '' then exit;
val(tempString,value,code);
if code > 0 then
begin
write(#7);
Make_Window(20,9,60,12,f,black);
write('Integer number expected.');
delay(1000);
Remove_Window;
gotoxy(xpos,ypos);
write(' ');
gotoxy(xpos,ypos);
end;
until code = 0
end;
{ -------------------------------------------------------- }
procedure GetRealVal(Var Value:real; xpos,ypos:Integer;
Var up,q:boolean);
{ Do error checking on real number input }
var
tempString, tempval : String10;
code : Integer;
begin
up := false;
q := false;
str(value,tempval);
gotoxy(xpos,ypos);
repeat
EditLine(tempString,8,wherex,wherey,LegalChars,Term,Tc);
Up := Tc = UpKey;
q := Tc = Esc;
val(tempString,value,code);
if code > 0 then
begin
write(#7);
Make_Window(20,9,60,12,f,b);
write('Real number expected.');
delay(1000);
Remove_Window;
gotoxy(xpos,ypos);
write(' ');
gotoxy(xpos,ypos);
end;
until code = 0
end;
function Exist(Filename:String80):boolean;
VAR infile:text;
Begin { Find out if the file exists }
Assign(Infile,Filename);
{$I-}
Reset(infile);
close(infile);
{$I+}
Exist := (IOresult = 0);
end;
function uppercase(progname:String80): String80;
{ Convert a String to upper case }
var
i : Integer;
begin
for i := 1 to length(progname) do
progname[i] := upcase(progname[i]);
uppercase := progname
end;
Procedure Exec(s : String80);
{ Execute DOS command or Program }
Var
save_ax : Integer;
Const
save_ss : Integer = 0;
save_sp : Integer = 0;
BEGIN
s[Length(s)+1] := ^M;
INLINE(
$1E/ { push ds }
$55/ { push bp }
$2E/$8C/$16/save_ss/ { mov cs:[save_ss],ss }
$2E/$89/$26/save_sp/ { mov cs:[save_sp],sp }
$8C/$D0/ { mov ax,ss }
$8E/$D8/ { mov ds,ax }
$8D/$76/<s/ { lea si,s[bp] }
$CD/$2E/ { int 2eh }
$2E/$8E/$16/save_ss/ { mov ss,cs:[save_ss] }
$2E/$8B/$26/save_sp/ { mov sp,cs:[save_sp] }
$5D/ { pop bp }
$1F/ { pop ds }
$89/$46/<save_ax { mov save_ax[bp],ax }
);
IF save_ax <> 0 THEN WriteLn('Exit code = ', save_ax);
End;
procedure Zero;
begin
FillChar(zero1,ofs(zero2) - ofs(zero1) + sizeof(zero2), 0);
end;
procedure help(pos:Integer);
{ Read and display help.txt }
const
filename = 'help.txt';
var
ch : char;
i : Integer;
begin
if not exist(filename) then
begin
Make_Window(20,10,60,14,hf,hb);
writeln(' Help file ''help.txt'' not found.');
write(' Press any key...');
clock;
Ch := ReadKey;
Remove_Window
end else
begin
Make_Window(5,4,75,23,hf,hb);
i := 1;
assign(helpfile,filename);
reset(helpfile);
while not eof(helpfile) do
begin
seek(helpfile,pos-1);
read(helpfile,trec);
fwrite(7,i+3,hb*16+hf,trec.fString);
i := succ(i);
pos := succ(pos);
if i > 15 then
begin
i := 1;
writeln;
fwrite(10,21,hb*16+4,'Press "-" or "+" or ESC to exit...');
gotoxy(47,18);
clock;
repeat
Ch := ReadKey;
until ch in ['-','+',ESC];
clrscr;
if ch = '-' then pos := pos - 30;
if pos < 1 then pos := 1;
if ch = ESC then
begin
close(helpfile);
textbackground(b);
Remove_Window;
exit
end;
clrscr;
end;
end;
fwrite(10,21,hb*16+4,'Press any key to exit help...');
gotoxy(35,18);
clock;
Ch := ReadKey;
close(helpfile);
textbackground(b);
Remove_Window;
end;
end;
procedure setprn(var c:char; var can:char);
{ Set up printer }
var
d : text;
ch : char;
begin
assign(d,prnfile);
rewrite(d);
make_window(30,10,50,18,f,b);
writeln;
writeln(' 1 - Epson');
writeln(' 2 - Okidata');
repeat
Ch := ReadKey;
until ch in ['1'..'3'];
case ch of
'1': begin
preset := #27+#69;
normal := #27+#69;
expanded := #14;
end;
'2': begin
preset := #24;
normal := #30;
expanded := #31;
end;
end; { Case }
writeln(d,preset);
writeln(d,normal);
writeln(d,expanded);
writeln(d,can);
close(d);
remove_window
end;
procedure loadprn(var c:char; var can:char);
var
d : text;
begin
if exist(prnfile) then
begin
assign(d,prnfile);
reset(d);
readln(d,preset);
readln(d,normal);
readln(d,expanded);
close(d);
end else
begin
c := #29; { Okidata Compress Code By Default }
can := #30 { Okidata Cancel Code }
end;
end;
{ -------------------------------------------------------- }
procedure display_colors(n:Integer);
var
i : Integer;
begin
writeln;
textbackground(black);
for i := 1 to n do
begin
textcolor(i);
write(i:3)
end;
textcolor(15);
writeln
end;
procedure save_setupfile;
var
textfile : text;
begin
assign(textfile,setupfile);
rewrite(textfile);
writeln(textfile,title);
writeln(textfile,f);
writeln(textfile,b);
writeln(textfile,wf1);
writeln(textfile,fc);
writeln(textfile,wb1);
writeln(textfile,wf2);
writeln(textfile,wb2);
writeln(textfile,lfg);
writeln(textfile,lbg);
writeln(textfile,bar_color);
writeln(textfile,pattern);
writeln(textfile,hf);
writeln(textfile,hb);
writeln(textfile,pr);
close(textfile);
end;
procedure clear_windows;
var
i : Integer;
begin
for i := 1 to 5 do
remove_window
end;
function free(dr:char):real;
{ Compute free disk space }
var
reg:registers;
begin
with reg do
begin
ah := $36; { DOS function number }
case upcase(dr) of
'A': dl := $01;
'B': dl := $02;
'C': dl := $03;
else dl := $00; { drive number : 00=default, 01=A, 02=B, etc.}
end;
MSDOS(reg); { call DOS }
free := 1.0*ax*bx*cx { multiply by 1.0 to create a real value}
end;
end;
procedure logo;
var
i : Integer;
line : String60;
begin
textbackground(lbg);
textcolor(lfg);
window(5,2,75,9);
clrscr;
gotoxy(1,4);
writeln(' ',title);
window(1,1,79,25);
line := Strings(60,#176);
for i := 10 to 23 do
fwrite(10,i,pattern,line);
textcolor(white);
textbackground(black);
end;
procedure display_size;
var
n : real;
s : Integer;
num : String10;
begin
n := filesize(d);
str(n:4:0,num);
fwrite(6,6,lbg*16+lfg,'Number of records = '+num);
s := sizeof(rec) * round(n);
str(s:7,num);
fwrite(6,7,lbg*16+lfg,'Database size = '+num+' bytes');
n := free(' ');
str(n:8:0,num);
fwrite(38,6,lbg*16+lfg,'Free disk space = '+num+' bytes ');
end;
procedure main_menu;
begin
clear_windows;
TextBackground(Black);
ClrScr;
logo;
Make_Window(16,13,38,22,wf1,wb1);
textcolor(fc); write(' F1: ');
textcolor(wf1); writeln('Help');
textcolor(fc); write(' F2: ');
textcolor(wf1); writeln('Printer setup');
textcolor(fc); write(' F3: ');
textcolor(wf1); writeln('Colors');
textcolor(fc); write(' F4: ');
textcolor(wf1); writeln('Clock On/Off');
textcolor(fc); write(' F5: ');
textcolor(wf1); writeln('Sort');
textcolor(fc); write(' F6: ');
textcolor(wf1); writeln('Shrink');
textcolor(fc); write(' F7: ');
textcolor(wf1); writeln('Backup Data');
textcolor(fc); write(' ESC');
textcolor(wf1); write('-Exit ');
Make_Window(41,13,63,22,wf2,wb2)
end;
{ -------------------------------------------------------- }
Procedure Display_Choices(n:Integer);
var
i, x, y : Integer;
begin
x := 1;
y := 1;
if Color_Monitor then textbackground(b);
clrscr;
for i := 1 to n do
begin
y := y + 1;
if y > 16 then
begin
x := x + 19;
y := 2
end;
gotoxy(x,y);
writeln(' '+Menu[i],spaces(18-length(menu[i])));
end;
end;
procedure get_colors;
var
temp : String60;
i : Integer;
q, up : boolean;
begin
Make_Window(1,5,79,20,white,black);
temp := '';
textcolor(white);
textbackground(black);
Writeln('Title - ',title,' --> ');
EditLine(temp,60,wherex,wherey,LegalChars,Term,Tc);
if (temp <> title) and (temp <> '') then title := temp;
temp := '';
display_colors(15);
if lfg = black then textcolor(white) else
textcolor(lfg);
write('Title text color ',lfg:2,' --> ');
getintval(lfg,wherex,wherey,up,q);
display_colors(7);
textcolor(lbg);
write('Title background color ',lbg:2,' --> ');
getintval(lbg,wherex,wherey,up,q);
display_colors(15);
textcolor(wf1);
write('Left window text color ',wf1:2,' --> ');
getintval(wf1,wherex,wherey,up,q);
display_colors(15);
textcolor(fc);
write('Left window function key color ',fc:2,' --> ');
getintval(fc,wherex,wherey,up,q);
display_colors(7);
textcolor(wb1);
repeat
write('left window background color ',wb1:2,' --> ');
getintval(wb1,wherex,wherey,up,q);
writeln;
until wb1 in [0..7];
display_colors(15);
textcolor(wf2);
write('Right window text color ',wf2:2,' --> ');
getintval(wf2,wherex,wherey,up,q);
repeat;
writeln;
display_colors(7);
textcolor(wb2);
write('Right window background color ',wb2,' --> ');
getintval(wb2,wherex,wherey,up,q);
until wb2 in [0..7];
display_colors(15);
textcolor(bar_color);
write('Slide Bar color ',bar_color:2,' --> ');
getintval(Bar_color,wherex,wherey,up,q);
textcolor(pattern);
display_colors(15);
write('Pattern Color ',pattern:2,' --> ');
getintval(pattern,wherex,wherey,up,q);
display_colors(15);
write('Help window foreground color ',hf:2,' --> ');
getintval(hf,wherex,wherey,up,q);
display_colors(7);
write('Help window background color ',hb:2,' --> ');
getintval(hb,wherex,wherey,up,q);
Save_SetupFile;
for i := 1 to 3 do Remove_Window;
main_menu;
Display_Choices(3);
end;
procedure configure;
var
textfile : text;
i : Integer;
begin
if exist(setupfile) then
begin
assign(textfile,setupfile);
reset(textfile);
readln(textfile,title);
readln(textfile,f);
readln(textfile,b);
readln(textfile,wf1);
readln(textfile,fc);
readln(textfile,wb1);
readln(textfile,wf2);
readln(textfile,wb2);
readln(textfile,lfg);
readln(textfile,lbg);
readln(textfile,bar_color);
readln(textfile,pattern);
readln(textfile,hf);
readln(textfile,hb);
readln(textfile,pr);
close(textfile);
end else
begin
clear_windows;
clrscr;
get_colors
end;
end;